Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume23 / pascal / part01 next >

Wrap

Text File | 1991-09-27 | 55.6 KB | 1,873 lines

Newsgroups: comp.sources.misc From: steven@cwi.nl (Steven Pemberton) Subject: v23i025: pascal - Public domain Pascal Compiler and Interpreter, Part01/03 Message-ID: <csm-v23i025=pascal.231008@sparky.IMD.Sterling.COM> X-Md4-Signature: ffb57898f8934e31e7b62c5bee2a26d1 Date: Fri, 27 Sep 1991 04:11:51 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: steven@cwi.nl (Steven Pemberton) Posting-number: Volume 23, Issue 25 Archive-name: pascal/part01 Environment: Pascal Due to public demand following postings to comp.lang.misc and comp.compilers, here are the sources of a public domain Pascal compiler and interpreter. This is the Pascal source of a public domain Pascal compiler and interpreter. The entire code is documented in the book: Pascal Implementation by Steven Pemberton and Martin Daniels published by Ellis Horwood, Chichester, UK, (also available in Japanese). It was distributed by John Wiley in other countries, but now that Prentice Hall has taken over Ellis Horwood, that may have changed. Best wishes, Steven Pemberton, CWI, Amsterdam; steven@cwi.nl ----- #!/bin/sh # This is a shell archive (produced by shar 3.49) # To extract the files from this archive, save it to a file, remove # everything above the "!/bin/sh" line above, and type "sh file_name". # # existing files will NOT be overwritten unless -c is specified # # This is part 1 of a multipart archive # do not concatenate these parts, unpack them in order with /bin/sh # # This shar contains: # length mode name # ------ ---------- ------------------------------------------ # 6433 -rw-r--r-- READ.ME # 117626 -rw-r--r-- pcom.p # 28139 -rw-r--r-- pint.p # if test -r _shar_seq_.tmp; then echo 'Must unpack archives in sequence!' echo Please unpack part `cat _shar_seq_.tmp` next exit 1 fi # ============= READ.ME ============== if test -f 'READ.ME' -a X"$1" != X"-c"; then echo 'x - skipping READ.ME (File already exists)' rm -f _shar_wnt_.tmp else > _shar_wnt_.tmp echo 'x - extracting READ.ME (Text)' sed 's/^X//' << 'SHAR_EOF' > 'READ.ME' && This is the Pascal source of a public domain Pascal compiler and interpreter. The entire code is documented in the book: X Pascal Implementation X by Steven Pemberton and Martin Daniels X published by Ellis Horwood, Chichester, UK, (also available in Japanese). It was distributed by John Wiley in other countries, but now that Prentice Hall has taken over Ellis Horwood, that may have changed. X Steven Pemberton is contactable by email as steven@cwi.nl. X The code here is slightly different from that in the book, but the line numbers have been kept the same. The changes were to allow modern Pascal compilers to compile the source (there were some slight laxities in the original code). X The type marktype is added for the parameters of the routines mark and release: X 76c76 X < X --- X > marktype= ^integer; X The type setty (which represents set types) is added for the new type compatibility rules of ISO Pascal: X 95c95 X < X --- X > setty = set of setlow..sethigh; X 100c100 X < pset: (pval: set of setlow..sethigh); X --- X > pset: (pval: setty); X Missing variant parts: X 123c123 X < declared: (fconst: ctp)); X --- X > declared: (fconst: ctp); standard: ()); X 145a146 X > types: (); X 149,150c150 X < proc, X < func: (case pfdeckind: declkind of X --- X > proc, func: (case pfdeckind: declkind of X 154,155c154,155 X < actual: (forwdecl, extern: X < boolean))) X --- X > actual: (forwdecl, extern: boolean); X > formal: ())) X Pcom has the files prr and prd as standard identifiers. You have to declare them for other compilers: X 193d192 X < X 194a194 X > prr: text; (* comment this out when compiling with pcom *) X 299d298 X < X Other compilers don't have the routines mark and release. Their effective semantics are null; you just waste heap: X 300a300,301 X > procedure mark(var p: marktype); begin end; X > procedure release(p: marktype); begin end; X 302d302 X < X Output the line number with error messages, so that if the listing option has been switched off, you still know which line is in error: X 307c307 X < begin write(output,' **** ':15); X --- X > begin write(output,linecount:6,' **** ':9); X Accept tabs as white-space as well: X 398c398 X < repeat while (ch = ' ') and not eol do nextch; X --- X > repeat while ((ch = ' ') or (ch = ' ')) and not eol do nextch; X Jumping from the then part of an if into the else part is not allowed; fix cases like 1..10 in another way: X 429c429 X < if (ch = '.') or (ch = 'e') then X --- X > if ((ch = '.') and (input^ <> '.')) or (ch = 'e') then X 434c434 X < nextch; if ch = '.' then begin ch := ':'; goto 3 end; X --- X > nextch; (*if ch = '.' then begin ch := ':'; goto 3 end;*) X Fix modern type mismatches: X 668c668 X < procedure align(fsp: stp; var flc: integer); X --- X > procedure align(fsp: stp; var flc: addrrange); X An identifier misspelled after the 8th character: X 872c872 X < if sy = stringconstsy then X --- X > if sy = stringconst then X Unused variables, and new type names: X 1529,1531c1529,1531 X < var oldlev: 0..maxlevel; lsy: symbol; lcp,lcp1: ctp; lsp: stp; X < forw: boolean; oldtop: disprange; parcnt: integer; X < llc,lcm: addrrange; lbname: integer; markp: ^integer; X --- X > var oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp; X > forw: boolean; oldtop: disprange; X > llc,lcm: addrrange; lbname: integer; markp: marktype; X 1535c1535 X < llc: addrrange; count,lsize: integer; X --- X > llc,lsize: addrrange; count: integer; X 1819c1819 X < i, entname, segsize: integer; X --- X > entname, segsize: integer; X 2087c2087 X < var lattr: attr; lcp: ctp; lsize,lmin,lmax: integer; X --- X > var lattr: attr; lcp: ctp; lsize: addrrange; lmin,lmax: integer; X 2248c2248 X < var lcp:ctp; llev:levrange; laddr:addrrange; X --- X > var llev:levrange; laddr:addrrange; X 2306c2306 X < lcp:ctp; llev:levrange; laddr,len:addrrange; X --- X > llev:levrange; laddr,len:addrrange; X 2456,2457c2456,2457 X < var lsp,lsp1: stp; varts,lmin,lmax: integer; X < lsize,lsz: addrrange; lval: valu; X --- X > var lsp,lsp1: stp; varts: integer; X > lsize: addrrange; lval: valu; X 2750c2750 X < cstpart: set of 0..47; lsp: stp; X --- X > cstpart: setty; lsp: stp; X Unix pc can't cope with this line: X 2926c2926 X < (*/*) rdiv: begin X --- X > (* / *) rdiv: begin X More unused variables: X 3318c3318 X < var lattr: attr; lsp: stp; lsy: symbol; X --- X > var lattr: attr; lsy: symbol; X 3642c3642 X < var sp: stp; X --- X > X Produce code as default: X 3800c3800 X < prtables := false; list := true; prcode := false; debug := true; X --- X > prtables := false; list := true; prcode := true; debug := true; X Unused variable: X 3868c3868 X < var i: integer; ch: char; X --- X > var i: integer; X Other compilers need to rewrite prr before using it: X 3995,3996c3995,3996 X < (*compile:*) X < (**********) X --- X > (*compile:*) rewrite(prr); (*comment this out when compiling with pcom *) X > (**********) X Differences in the interpreter are minimal: a set type has been added: X X 45a46 X > settype = set of 0..58; X 63c64 X < sett :(vs :set of 0..47); X --- X > sett :(vs :settype); X 225c226 X < var name :alfa; b :boolean; r :real; s :set of 0..58; X --- X > var name :alfa; b :boolean; r :real; s :settype; X End of differences SHAR_EOF chmod 0644 READ.ME || echo 'restore of READ.ME failed' Wc_c="`wc -c < 'READ.ME'`" test 6433 -eq "$Wc_c" || echo 'READ.ME: original size 6433, current size' "$Wc_c" rm -f _shar_wnt_.tmp fi # ============= pcom.p ============== if test -f 'pcom.p' -a X"$1" != X"-c"; then echo 'x - skipping pcom.p (File already exists)' rm -f _shar_wnt_.tmp else > _shar_wnt_.tmp echo 'x - extracting pcom.p (Text)' sed 's/^X//' << 'SHAR_EOF' > 'pcom.p' && (*$c+,t-,d-,l-*) X (*********************************************** X * * X * Portable Pascal compiler * X * ************************ * X * * X * Pascal P4 * X * * X * Authors: * X * Urs Ammann * X * Kesav Nori * X * Christian Jacobi * X * Address: * X * Institut Fuer Informatik * X * Eidg. Technische Hochschule * X * CH-8096 Zuerich * X * * X * This code is fully documented in the book * X * "Pascal Implementation" * X * by Steven Pemberton and Martin Daniels * X * published by Ellis Horwood, Chichester, UK * X * (also available in Japanese) * X * * X * Steven Pemberton, CWI/AA, * X * Kruislaan 413, 1098 SJ Amsterdam, NL * X * steven@cwi.nl * X * * X * * X ***********************************************) X program pascalcompiler(input,output,prr); X const displimit = 20; maxlevel = 10; X intsize = 1; X intal = 1; X realsize = 1; X realal = 1; X charsize = 1; X charal = 1; X charmax = 1; X boolsize = 1; X boolal = 1; X ptrsize = 1; X adral = 1; X setsize = 1; X setal = 1; X stackal = 1; X stackelsize = 1; X strglgth = 16; X sethigh = 47; X setlow = 0; X ordmaxchar = 63; X ordminchar = 0; X maxint = 32767; X lcaftermarkstack = 5; X fileal = charal; X (* stackelsize = minimum size for 1 stackelement X = k*stackal X stackal = scm(all other al-constants) X charmax = scm(charsize,charal) X scm = smallest common multiple X lcaftermarkstack >= 4*ptrsize+max(x-size) X = k1*stackelsize *) X maxstack = 1; X parmal = stackal; X parmsize = stackelsize; X recal = stackal; X filebuffer = 4; X maxaddr = maxint; X X X type (*describing:*) X (*************) X X marktype= ^integer; X (*basic symbols*) X (***************) X X symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop, X lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow, X colon,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy, X procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy, X beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy, X gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy, X thensy,othersy); X operator = (mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop, X neop,eqop,inop,noop); X setofsys = set of symbol; X chtp = (letter,number,special,illegal, X chstrquo,chcolon,chperiod,chlt,chgt,chlparen,chspace); X X (*constants*) X (***********) X setty = set of setlow..sethigh; X cstclass = (reel,pset,strg); X csp = ^ constant; X constant = record case cclass: cstclass of X reel: (rval: packed array [1..strglgth] of char); X pset: (pval: setty); X strg: (slgth: 0..strglgth; X sval: packed array [1..strglgth] of char) X end; X X valu = record case intval: boolean of (*intval never set nor tested*) X true: (ival: integer); X false: (valp: csp) X end; X X (*data structures*) X (*****************) X levrange = 0..maxlevel; addrrange = 0..maxaddr; X structform = (scalar,subrange,pointer,power,arrays,records,files, X tagfld,variant); X declkind = (standard,declared); X stp = ^ structure; ctp = ^ identifier; X X structure = packed record X marked: boolean; (*for test phase only*) X size: addrrange; X case form: structform of X scalar: (case scalkind: declkind of X declared: (fconst: ctp); standard: ()); X subrange: (rangetype: stp; min,max: valu); X pointer: (eltype: stp); X power: (elset: stp); X arrays: (aeltype,inxtype: stp); X records: (fstfld: ctp; recvar: stp); X files: (filtype: stp); X tagfld: (tagfieldp: ctp; fstvar: stp); X variant: (nxtvar,subvar: stp; varval: valu) X end; X X (*names*) X (*******) X X idclass = (types,konst,vars,field,proc,func); X setofids = set of idclass; X idkind = (actual,formal); X alpha = packed array [1..8] of char; X X identifier = packed record X name: alpha; llink, rlink: ctp; X idtype: stp; next: ctp; X case klass: idclass of X types: (); X konst: (values: valu); X vars: (vkind: idkind; vlev: levrange; vaddr: addrrange); X field: (fldaddr: addrrange); X proc, func: (case pfdeckind: declkind of X standard: (key: 1..15); X declared: (pflev: levrange; pfname: integer; X case pfkind: idkind of X actual: (forwdecl, extern: boolean); X formal: ())) X end; X X X disprange = 0..displimit; X where = (blck,crec,vrec,rec); X X (*expressions*) X (*************) X attrkind = (cst,varbl,expr); X vaccess = (drct,indrct,inxd); X X attr = record typtr: stp; X case kind: attrkind of X cst: (cval: valu); X varbl: (case access: vaccess of X drct: (vlevel: levrange; dplmt: addrrange); X indrct: (idplmt: addrrange)) X end; X X testp = ^ testpointer; X testpointer = packed record X elt1,elt2 : stp; X lasttestp : testp X end; X X (*labels*) X (********) X lbp = ^ labl; X labl = record nextlab: lbp; defined: boolean; X labval, labname: integer X end; X X extfilep = ^filerec; X filerec = record filename:alpha; nextfile:extfilep end; X (*-------------------------------------------------------------------------*) X var (* prr: text; (* comment this out when compiling with pcom *) X (*returned by source program scanner X insymbol: X **********) X X sy: symbol; (*last symbol*) X op: operator; (*classification of last symbol*) X val: valu; (*value of last constant*) X lgth: integer; (*length of last string constant*) X id: alpha; (*last identifier (possibly truncated)*) X kk: 1..8; (*nr of chars in last identifier*) X ch: char; (*last character*) X eol: boolean; (*end of line flag*) X X X (*counters:*) X (***********) X X chcnt: integer; (*character counter*) X lc,ic: addrrange; (*data location and instruction counter*) X linecount: integer; X X X (*switches:*) X (***********) X X dp, (*declaration part*) X prterr, (*to allow forward references in pointer type X declaration by suppressing error message*) X list,prcode,prtables: boolean; (*output options for X -- source program listing X -- printing symbolic code X -- displaying ident and struct tables X --> procedure option*) X debug: boolean; X X X (*pointers:*) X (***********) X parmptr, X intptr,realptr,charptr, X boolptr,nilptr,textptr: stp; (*pointers to entries of standard ids*) X utypptr,ucstptr,uvarptr, X ufldptr,uprcptr,ufctptr, (*pointers to entries for undeclared ids*) X fwptr: ctp; (*head of chain of forw decl type ids*) X fextfilep: extfilep; (*head of chain of external files*) X globtestp: testp; (*last testpointer*) X X X (*bookkeeping of declaration levels:*) X (************************************) X X level: levrange; (*current static level*) X disx, (*level of last id searched by searchid*) X top: disprange; (*top of display*) X X display: (*where: means:*) X array [disprange] of X packed record (*=blck: id is variable id*) X fname: ctp; flabel: lbp; (*=crec: id is field id in record with*) X case occur: where of (* constant address*) X crec: (clev: levrange; (*=vrec: id is field id in record with*) X cdspl: addrrange);(* variable address*) X vrec: (vdspl: addrrange) X end; (* --> procedure withstatement*) X X X (*error messages:*) X (*****************) X X errinx: 0..10; (*nr of errors in current source line*) X errlist: X array [1..10] of X packed record pos: integer; X nmr: 1..400 X end; X X X X (*expression compilation:*) X (*************************) X X gattr: attr; (*describes the expr currently compiled*) X X X (*structured constants:*) X (***********************) X X constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys, X statbegsys,typedels: setofsys; X chartp : array[char] of chtp; X rw: array [1..35(*nr. of res. words*)] of alpha; X frw: array [1..9] of 1..36(*nr. of res. words + 1*); X rsy: array [1..35(*nr. of res. words*)] of symbol; X ssy: array [char] of symbol; X rop: array [1..35(*nr. of res. words*)] of operator; X sop: array [char] of operator; X na: array [1..35] of alpha; X mn: array [0..60] of packed array [1..4] of char; X sna: array [1..23] of packed array [1..4] of char; X cdx: array [0..60] of -4..+4; X pdx: array [1..23] of -7..+7; X ordint: array [char] of integer; X X intlabel,mxint10,digmax: integer; (*-------------------------------------------------------------------------*) X procedure mark(var p: marktype); begin end; X procedure release(p: marktype); begin end; X X procedure endofline; X var lastpos,freepos,currpos,currnmr,f,k: integer; X begin X if errinx > 0 then (*output error messages*) X begin write(output,linecount:6,' **** ':9); X lastpos := 0; freepos := 1; X for k := 1 to errinx do X begin X with errlist[k] do X begin currpos := pos; currnmr := nmr end; X if currpos = lastpos then write(output,',') X else X begin X while freepos < currpos do X begin write(output,' '); freepos := freepos + 1 end; X write(output,'^'); X lastpos := currpos X end; X if currnmr < 10 then f := 1 X else if currnmr < 100 then f := 2 X else f := 3; X write(output,currnmr:f); X freepos := freepos + f + 1 X end; X writeln(output); errinx := 0 X end; X linecount := linecount + 1; X if list and (not eof(input)) then X begin write(output,linecount:6,' ':2); X if dp then write(output,lc:7) else write(output,ic:7); X write(output,' ') X end; X chcnt := 0 X end (*endofline*) ; X X procedure error(ferrnr: integer); X begin X if errinx >= 9 then X begin errlist[10].nmr := 255; errinx := 10 end X else X begin errinx := errinx + 1; X errlist[errinx].nmr := ferrnr X end; X errlist[errinx].pos := chcnt X end (*error*) ; X X procedure insymbol; X (*read next basic symbol of source program and return its X description in the global variables sy, op, id, val and lgth*) X label 1,2,3; X var i,k: integer; X digit: packed array [1..strglgth] of char; X string: packed array [1..strglgth] of char; X lvp: csp; test: boolean; X X procedure nextch; X begin if eol then X begin if list then writeln(output); endofline X end; X if not eof(input) then X begin eol := eoln(input); read(input,ch); X if list then write(output,ch); X chcnt := chcnt + 1 X end X else X begin writeln(output,' *** eof ','encountered'); X test := false X end X end; X X procedure options; X begin X repeat nextch; X if ch <> '*' then X begin X if ch = 't' then X begin nextch; prtables := ch = '+' end X else X if ch = 'l' then X begin nextch; list := ch = '+'; X if not list then writeln(output) X end X else X if ch = 'd' then X begin nextch; debug := ch = '+' end X else X if ch = 'c' then X begin nextch; prcode := ch = '+' end; X nextch X end X until ch <> ',' X end (*options*) ; X X begin (*insymbol*) X 1: X repeat while ((ch = ' ') or (ch = ' ')) and not eol do nextch; X test := eol; X if test then nextch X until not test; X if chartp[ch] = illegal then X begin sy := othersy; op := noop; X error(399); nextch X end X else X case chartp[ch] of X letter: X begin k := 0; X repeat X if k < 8 then X begin k := k + 1; id[k] := ch end ; X nextch X until chartp[ch] in [special,illegal,chstrquo,chcolon, X chperiod,chlt,chgt,chlparen,chspace]; X if k >= kk then kk := k X else X repeat id[kk] := ' '; kk := kk - 1 X until kk = k; X for i := frw[k] to frw[k+1] - 1 do X if rw[i] = id then X begin sy := rsy[i]; op := rop[i]; goto 2 end; X sy := ident; op := noop; X 2: end; X number: X begin op := noop; i := 0; X repeat i := i+1; if i<= digmax then digit[i] := ch; nextch X until chartp[ch] <> number; X if ((ch = '.') and (input^ <> '.')) or (ch = 'e') then X begin X k := i; X if ch = '.' then X begin k := k+1; if k <= digmax then digit[k] := ch; X nextch; (*if ch = '.' then begin ch := ':'; goto 3 end;*) X if chartp[ch] <> number then error(201) X else X repeat k := k + 1; X if k <= digmax then digit[k] := ch; nextch X until chartp[ch] <> number X end; X if ch = 'e' then X begin k := k+1; if k <= digmax then digit[k] := ch; X nextch; X if (ch = '+') or (ch ='-') then X begin k := k+1; if k <= digmax then digit[k] := ch; X nextch X end; X if chartp[ch] <> number then error(201) X else X repeat k := k+1; X if k <= digmax then digit[k] := ch; nextch X until chartp[ch] <> number X end; X new(lvp,reel); sy:= realconst; lvp^.cclass := reel; X with lvp^ do X begin for i := 1 to strglgth do rval[i] := ' '; X if k <= digmax then X for i := 2 to k + 1 do rval[i] := digit[i-1] X else begin error(203); rval[2] := '0'; X rval[3] := '.'; rval[4] := '0' X end X end; X val.valp := lvp X end X else X 3: begin X if i > digmax then begin error(203); val.ival := 0 end X else X with val do X begin ival := 0; X for k := 1 to i do X begin X if ival <= mxint10 then X ival := ival*10+ordint[digit[k]] X else begin error(203); ival := 0 end X end; X sy := intconst X end X end X end; X chstrquo: X begin lgth := 0; sy := stringconst; op := noop; X repeat X repeat nextch; lgth := lgth + 1; X if lgth <= strglgth then string[lgth] := ch X until (eol) or (ch = ''''); X if eol then error(202) else nextch X until ch <> ''''; X lgth := lgth - 1; (*now lgth = nr of chars in string*) X if lgth = 0 then error(205) else X if lgth = 1 then val.ival := ord(string[1]) X else X begin new(lvp,strg); lvp^.cclass:=strg; X if lgth > strglgth then X begin error(399); lgth := strglgth end; X with lvp^ do X begin slgth := lgth; X for i := 1 to lgth do sval[i] := string[i] X end; X val.valp := lvp X end X end; X chcolon: X begin op := noop; nextch; X if ch = '=' then X begin sy := becomes; nextch end X else sy := colon X end; X chperiod: X begin op := noop; nextch; X if ch = '.' then X begin sy := colon; nextch end X else sy := period X end; X chlt: X begin nextch; sy := relop; X if ch = '=' then X begin op := leop; nextch end X else X if ch = '>' then X begin op := neop; nextch end X else op := ltop X end; X chgt: X begin nextch; sy := relop; X if ch = '=' then X begin op := geop; nextch end X else op := gtop X end; X chlparen: X begin nextch; X if ch = '*' then X begin nextch; X if ch = '$' then options; X repeat X while (ch <> '*') and not eof(input) do nextch; X nextch X until (ch = ')') or eof(input); X nextch; goto 1 X end; X sy := lparent; op := noop X end; X special: X begin sy := ssy[ch]; op := sop[ch]; X nextch X end; X chspace: sy := othersy X end (*case*) X end (*insymbol*) ; X X procedure enterid(fcp: ctp); X (*enter id pointed at by fcp into the name-table, X which on each declaration level is organised as X an unbalanced binary tree*) X var nam: alpha; lcp, lcp1: ctp; lleft: boolean; X begin nam := fcp^.name; X lcp := display[top].fname; X if lcp = nil then X display[top].fname := fcp X else X begin X repeat lcp1 := lcp; X if lcp^.name = nam then (*name conflict, follow right link*) X begin error(101); lcp := lcp^.rlink; lleft := false end X else X if lcp^.name < nam then X begin lcp := lcp^.rlink; lleft := false end X else begin lcp := lcp^.llink; lleft := true end X until lcp = nil; X if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp X end; X fcp^.llink := nil; fcp^.rlink := nil X end (*enterid*) ; X X procedure searchsection(fcp: ctp; var fcp1: ctp); X (*to find record fields and forward declared procedure id's X --> procedure proceduredeclaration X --> procedure selector*) X label 1; X begin X while fcp <> nil do X if fcp^.name = id then goto 1 X else if fcp^.name < id then fcp := fcp^.rlink X else fcp := fcp^.llink; 1: fcp1 := fcp X end (*searchsection*) ; X X procedure searchid(fidcls: setofids; var fcp: ctp); X label 1; X var lcp: ctp; X begin X for disx := top downto 0 do X begin lcp := display[disx].fname; X while lcp <> nil do X if lcp^.name = id then X if lcp^.klass in fidcls then goto 1 X else X begin if prterr then error(103); X lcp := lcp^.rlink X end X else X if lcp^.name < id then X lcp := lcp^.rlink X else lcp := lcp^.llink X end; X (*search not successful; suppress error message in case X of forward referenced type id in pointer type definition X --> procedure simpletype*) X if prterr then X begin error(104); X (*to avoid returning nil, reference an entry X for an undeclared id of appropriate class X --> procedure enterundecl*) X if types in fidcls then lcp := utypptr X else X if vars in fidcls then lcp := uvarptr X else X if field in fidcls then lcp := ufldptr X else X if konst in fidcls then lcp := ucstptr X else X if proc in fidcls then lcp := uprcptr X else lcp := ufctptr; X end; 1: fcp := lcp X end (*searchid*) ; X X procedure getbounds(fsp: stp; var fmin,fmax: integer); X (*get internal bounds of subrange or scalar type*) X (*assume fsp<>intptr and fsp<>realptr*) X begin X fmin := 0; fmax := 0; X if fsp <> nil then X with fsp^ do X if form = subrange then X begin fmin := min.ival; fmax := max.ival end X else X if fsp = charptr then X begin fmin := ordminchar; fmax := ordmaxchar X end X else X if fconst <> nil then X fmax := fconst^.values.ival X end (*getbounds*) ; X X function alignquot(fsp: stp): integer; X begin X alignquot := 1; X if fsp <> nil then X with fsp^ do X case form of X scalar: if fsp=intptr then alignquot := intal X else if fsp=boolptr then alignquot := boolal X else if scalkind=declared then alignquot := intal X else if fsp=charptr then alignquot := charal X else if fsp=realptr then alignquot := realal X else (*parmptr*) alignquot := parmal; X subrange: alignquot := alignquot(rangetype); X pointer: alignquot := adral; X power: alignquot := setal; X files: alignquot := fileal; X arrays: alignquot := alignquot(aeltype); X records: alignquot := recal; X variant,tagfld: error(501) X end X end (*alignquot*); X X procedure align(fsp: stp; var flc: addrrange); X var k,l: integer; X begin X k := alignquot(fsp); X l := flc-1; X flc := l + k - (k+l) mod k X end (*align*); X X procedure printtables(fb: boolean); X (*print data structure and name table*) X var i, lim: disprange; X X procedure marker; X (*mark data structure entries to avoid multiple printout*) X var i: integer; X X procedure markctp(fp: ctp); forward; X X procedure markstp(fp: stp); X (*mark data structures, prevent cycles*) X begin X if fp <> nil then X with fp^ do X begin marked := true; X case form of X scalar: ; X subrange: markstp(rangetype); X pointer: (*don't mark eltype: cycle possible; will be marked X anyway, if fp = true*) ; X power: markstp(elset) ; X arrays: begin markstp(aeltype); markstp(inxtype) end; X records: begin markctp(fstfld); markstp(recvar) end; X files: markstp(filtype); X tagfld: markstp(fstvar); X variant: begin markstp(nxtvar); markstp(subvar) end X end (*case*) X end (*with*) X end (*markstp*); X X procedure markctp; X begin X if fp <> nil then X with fp^ do X begin markctp(llink); markctp(rlink); X markstp(idtype) X end X end (*markctp*); X X begin (*marker*) X for i := top downto lim do X markctp(display[i].fname) X end (*marker*); X X procedure followctp(fp: ctp); forward; X X procedure followstp(fp: stp); X begin X if fp <> nil then X with fp^ do X if marked then X begin marked := false; write(output,' ':4,ord(fp):6,size:10); X case form of X scalar: begin write(output,'scalar':10); X if scalkind = standard then X write(output,'standard':10) X else write(output,'declared':10,' ':4,ord(fconst):6); X writeln(output) X end; X subrange: begin X write(output,'subrange':10,' ':4,ord(rangetype):6); X if rangetype <> realptr then X write(output,min.ival,max.ival) X else X if (min.valp <> nil) and (max.valp <> nil) then X write(output,' ',min.valp^.rval:9, X ' ',max.valp^.rval:9); X writeln(output); followstp(rangetype); X end; X pointer: writeln(output,'pointer':10,' ':4,ord(eltype):6); X power: begin writeln(output,'set':10,' ':4,ord(elset):6); X followstp(elset) X end; X arrays: begin X writeln(output,'array':10,' ':4,ord(aeltype):6,' ':4, X ord(inxtype):6); X followstp(aeltype); followstp(inxtype) X end; X records: begin X writeln(output,'record':10,' ':4,ord(fstfld):6,' ':4, X ord(recvar):6); followctp(fstfld); X followstp(recvar) X end; X files: begin write(output,'file':10,' ':4,ord(filtype):6); X followstp(filtype) X end; X tagfld: begin writeln(output,'tagfld':10,' ':4,ord(tagfieldp):6, X ' ':4,ord(fstvar):6); X followstp(fstvar) X end; X variant: begin writeln(output,'variant':10,' ':4,ord(nxtvar):6, X ' ':4,ord(subvar):6,varval.ival); X followstp(nxtvar); followstp(subvar) X end X end (*case*) X end (*if marked*) X end (*followstp*); X X procedure followctp; X var i: integer; X begin X if fp <> nil then X with fp^ do X begin write(output,' ':4,ord(fp):6,' ',name:9,' ':4,ord(llink):6, X ' ':4,ord(rlink):6,' ':4,ord(idtype):6); X case klass of X types: write(output,'type':10); X konst: begin write(output,'constant':10,' ':4,ord(next):6); X if idtype <> nil then X if idtype = realptr then X begin X if values.valp <> nil then X write(output,' ',values.valp^.rval:9) X end X else X if idtype^.form = arrays then (*stringconst*) X begin X if values.valp <> nil then X begin write(output,' '); X with values.valp^ do X for i := 1 to slgth do X write(output,sval[i]) X end X end X else write(output,values.ival) X end; X vars: begin write(output,'variable':10); X if vkind = actual then write(output,'actual':10) X else write(output,'formal':10); X write(output,' ':4,ord(next):6,vlev,' ':4,vaddr:6 ); X end; X field: write(output,'field':10,' ':4,ord(next):6,' ':4,fldaddr:6); X proc, X func: begin X if klass = proc then write(output,'procedure':10) X else write(output,'function':10); X if pfdeckind = standard then X write(output,'standard':10, key:10) X else X begin write(output,'declared':10,' ':4,ord(next):6); X write(output,pflev,' ':4,pfname:6); X if pfkind = actual then X begin write(output,'actual':10); X if forwdecl then write(output,'forward':10) X else write(output,'notforward':10); X if extern then write(output,'extern':10) X else write(output,'not extern':10); X end X else write(output,'formal':10) X end X end X end (*case*); X writeln(output); X followctp(llink); followctp(rlink); X followstp(idtype) X end (*with*) X end (*followctp*); X X begin (*printtables*) X writeln(output); writeln(output); writeln(output); X if fb then lim := 0 X else begin lim := top; write(output,' local') end; X writeln(output,' tables '); writeln(output); X marker; X for i := top downto lim do X followctp(display[i].fname); X writeln(output); X if not eol then write(output,' ':chcnt+16) X end (*printtables*); X X procedure genlabel(var nxtlab: integer); X begin intlabel := intlabel + 1; X nxtlab := intlabel X end (*genlabel*); X X procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp); X var lsy: symbol; test: boolean; X X procedure skip(fsys: setofsys); X (*skip input string until relevant symbol found*) X begin X if not eof(input) then X begin while not(sy in fsys) and (not eof(input)) do insymbol; X if not (sy in fsys) then insymbol X end X end (*skip*) ; X X procedure constant(fsys: setofsys; var fsp: stp; var fvalu: valu); X var lsp: stp; lcp: ctp; sign: (none,pos,neg); X lvp: csp; i: 2..strglgth; X begin lsp := nil; fvalu.ival := 0; X if not(sy in constbegsys) then X begin error(50); skip(fsys+constbegsys) end; X if sy in constbegsys then X begin X if sy = stringconst then X begin X if lgth = 1 then lsp := charptr X else X begin X new(lsp,arrays); X with lsp^ do X begin aeltype := charptr; inxtype := nil; X size := lgth*charsize; form := arrays X end X end; X fvalu := val; insymbol X end X else X begin X sign := none; X if (sy = addop) and (op in [plus,minus]) then X begin if op = plus then sign := pos else sign := neg; X insymbol X end; X if sy = ident then X begin searchid([konst],lcp); X with lcp^ do X begin lsp := idtype; fvalu := values end; X if sign <> none then X if lsp = intptr then X begin if sign = neg then fvalu.ival := -fvalu.ival end X else X if lsp = realptr then X begin X if sign = neg then X begin new(lvp,reel); X if fvalu.valp^.rval[1] = '-' then X lvp^.rval[1] := '+' X else lvp^.rval[1] := '-'; X for i := 2 to strglgth do X lvp^.rval[i] := fvalu.valp^.rval[i]; X fvalu.valp := lvp; X end X end X else error(105); X insymbol; X end X else X if sy = intconst then X begin if sign = neg then val.ival := -val.ival; X lsp := intptr; fvalu := val; insymbol X end X else X if sy = realconst then X begin if sign = neg then val.valp^.rval[1] := '-'; X lsp := realptr; fvalu := val; insymbol X end X else X begin error(106); skip(fsys) end X end; X if not (sy in fsys) then X begin error(6); skip(fsys) end X end; X fsp := lsp X end (*constant*) ; X X function equalbounds(fsp1,fsp2: stp): boolean; X var lmin1,lmin2,lmax1,lmax2: integer; X begin X if (fsp1=nil) or (fsp2=nil) then equalbounds := true X else X begin X getbounds(fsp1,lmin1,lmax1); X getbounds(fsp2,lmin2,lmax2); X equalbounds := (lmin1=lmin2) and (lmax1=lmax2) X end X end (*equalbounds*) ; X X function comptypes(fsp1,fsp2: stp) : boolean; X (*decide whether structures pointed at by fsp1 and fsp2 are compatible*) X var nxt1,nxt2: ctp; comp: boolean; X ltestp1,ltestp2 : testp; X begin X if fsp1 = fsp2 then comptypes := true X else X if (fsp1 <> nil) and (fsp2 <> nil) then X if fsp1^.form = fsp2^.form then X case fsp1^.form of X scalar: X comptypes := false; X (* identical scalars declared on different levels are X not recognized to be compatible*) X subrange: X comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype); X pointer: X begin X comp := false; ltestp1 := globtestp; X ltestp2 := globtestp; X while ltestp1 <> nil do X with ltestp1^ do X begin X if (elt1 = fsp1^.eltype) and X (elt2 = fsp2^.eltype) then comp := true; X ltestp1 := lasttestp X end; X if not comp then X begin new(ltestp1); X with ltestp1^ do X begin elt1 := fsp1^.eltype; X elt2 := fsp2^.eltype; X lasttestp := globtestp X end; X globtestp := ltestp1; X comp := comptypes(fsp1^.eltype,fsp2^.eltype) X end; X comptypes := comp; globtestp := ltestp2 X end; X power: X comptypes := comptypes(fsp1^.elset,fsp2^.elset); X arrays: X begin X comp := comptypes(fsp1^.aeltype,fsp2^.aeltype) X and comptypes(fsp1^.inxtype,fsp2^.inxtype); X comptypes := comp and (fsp1^.size = fsp2^.size) and X equalbounds(fsp1^.inxtype,fsp2^.inxtype) X end; X records: X begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true; X while (nxt1 <> nil) and (nxt2 <> nil) do X begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype); X nxt1 := nxt1^.next; nxt2 := nxt2^.next X end; X comptypes := comp and (nxt1 = nil) and (nxt2 = nil) X and(fsp1^.recvar = nil)and(fsp2^.recvar = nil) X end; X (*identical records are recognized to be compatible X iff no variants occur*) X files: X comptypes := comptypes(fsp1^.filtype,fsp2^.filtype) X end (*case*) X else (*fsp1^.form <> fsp2^.form*) X if fsp1^.form = subrange then X comptypes := comptypes(fsp1^.rangetype,fsp2) X else X if fsp2^.form = subrange then X comptypes := comptypes(fsp1,fsp2^.rangetype) X else comptypes := false X else comptypes := true X end (*comptypes*) ; X X function string(fsp: stp) : boolean; X begin string := false; X if fsp <> nil then X if fsp^.form = arrays then X if comptypes(fsp^.aeltype,charptr) then string := true X end (*string*) ; X X procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange); X var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp; X lsize,displ: addrrange; lmin,lmax: integer; X X procedure simpletype(fsys:setofsys; var fsp:stp; var fsize:addrrange); X var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange; X lcnt: integer; lvalu: valu; X begin fsize := 1; X if not (sy in simptypebegsys) then X begin error(1); skip(fsys + simptypebegsys) end; X if sy in simptypebegsys then X begin X if sy = lparent then X begin ttop := top; (*decl. consts local to innermost block*) X while display[top].occur <> blck do top := top - 1; X new(lsp,scalar,declared); X with lsp^ do X begin size := intsize; form := scalar; X scalkind := declared X end; X lcp1 := nil; lcnt := 0; X repeat insymbol; X if sy = ident then X begin new(lcp,konst); X with lcp^ do X begin name := id; idtype := lsp; next := lcp1; X values.ival := lcnt; klass := konst X end; X enterid(lcp); X lcnt := lcnt + 1; X lcp1 := lcp; insymbol X end X else error(2); X if not (sy in fsys + [comma,rparent]) then X begin error(6); skip(fsys + [comma,rparent]) end X until sy <> comma; X lsp^.fconst := lcp1; top := ttop; X if sy = rparent then insymbol else error(4) X end X else X begin X if sy = ident then X begin searchid([types,konst],lcp); X insymbol; X if lcp^.klass = konst then X begin new(lsp,subrange); X with lsp^, lcp^ do X begin rangetype := idtype; form := subrange; X if string(rangetype) then X begin error(148); rangetype := nil end; X min := values; size := intsize X end; X if sy = colon then insymbol else error(5); X constant(fsys,lsp1,lvalu); X lsp^.max := lvalu; X if lsp^.rangetype <> lsp1 then error(107) X end X else X begin lsp := lcp^.idtype; X if lsp <> nil then fsize := lsp^.size X end X end (*sy = ident*) X else X begin new(lsp,subrange); lsp^.form := subrange; X constant(fsys + [colon],lsp1,lvalu); X if string(lsp1) then X begin error(148); lsp1 := nil end; X with lsp^ do X begin rangetype:=lsp1; min:=lvalu; size:=intsize end; X if sy = colon then insymbol else error(5); X constant(fsys,lsp1,lvalu); X lsp^.max := lvalu; X if lsp^.rangetype <> lsp1 then error(107) X end; X if lsp <> nil then X with lsp^ do X if form = subrange then X if rangetype <> nil then X if rangetype = realptr then error(399) X else X if min.ival > max.ival then error(102) X end; X fsp := lsp; X if not (sy in fsys) then X begin error(6); skip(fsys) end X end X else fsp := nil X end (*simpletype*) ; X X procedure fieldlist(fsys: setofsys; var frecvar: stp); X var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp; X minsize,maxsize,lsize: addrrange; lvalu: valu; X begin nxt1 := nil; lsp := nil; X if not (sy in (fsys+[ident,casesy])) then X begin error(19); skip(fsys + [ident,casesy]) end; X while sy = ident do X begin nxt := nxt1; X repeat X if sy = ident then X begin new(lcp,field); X with lcp^ do X begin name := id; idtype := nil; next := nxt; X klass := field X end; X nxt := lcp; X enterid(lcp); X insymbol X end X else error(2); X if not (sy in [comma,colon]) then X begin error(6); skip(fsys + [comma,colon,semicolon,casesy]) X end; X test := sy <> comma; X if not test then insymbol X until test; X if sy = colon then insymbol else error(5); X typ(fsys + [casesy,semicolon],lsp,lsize); X while nxt <> nxt1 do X with nxt^ do X begin align(lsp,displ); X idtype := lsp; fldaddr := displ; X nxt := next; displ := displ + lsize X end; X nxt1 := lcp; X while sy = semicolon do X begin insymbol; X if not (sy in fsys + [ident,casesy,semicolon]) then X begin error(19); skip(fsys + [ident,casesy]) end X end X end (*while*); X nxt := nil; X while nxt1 <> nil do X with nxt1^ do X begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end; X if sy = casesy then X begin new(lsp,tagfld); X with lsp^ do X begin tagfieldp := nil; fstvar := nil; form:=tagfld end; X frecvar := lsp; X insymbol; X if sy = ident then X begin new(lcp,field); X with lcp^ do X begin name := id; idtype := nil; klass:=field; X next := nil; fldaddr := displ X end; X enterid(lcp); X insymbol; X if sy = colon then insymbol else error(5); X if sy = ident then X begin searchid([types],lcp1); X lsp1 := lcp1^.idtype; X if lsp1 <> nil then X begin align(lsp1,displ); X lcp^.fldaddr := displ; X displ := displ+lsp1^.size; X if (lsp1^.form <= subrange) or string(lsp1) then X begin if comptypes(realptr,lsp1) then error(109) X else if string(lsp1) then error(399); X lcp^.idtype := lsp1; lsp^.tagfieldp := lcp; X end X else error(110); X end; X insymbol; X end X else begin error(2); skip(fsys + [ofsy,lparent]) end X end X else begin error(2); skip(fsys + [ofsy,lparent]) end; X lsp^.size := displ; X if sy = ofsy then insymbol else error(8); X lsp1 := nil; minsize := displ; maxsize := displ; X repeat lsp2 := nil; X if not (sy in fsys + [semicolon]) then X begin X repeat constant(fsys + [comma,colon,lparent],lsp3,lvalu); X if lsp^.tagfieldp <> nil then X if not comptypes(lsp^.tagfieldp^.idtype,lsp3)then error(111); X new(lsp3,variant); X with lsp3^ do X begin nxtvar := lsp1; subvar := lsp2; varval := lvalu; X form := variant X end; X lsp4 := lsp1; X while lsp4 <> nil do X with lsp4^ do X begin X if varval.ival = lvalu.ival then error(178); X lsp4 := nxtvar X end; X lsp1 := lsp3; lsp2 := lsp3; X test := sy <> comma; X if not test then insymbol X until test; X if sy = colon then insymbol else error(5); X if sy = lparent then insymbol else error(9); X fieldlist(fsys + [rparent,semicolon],lsp2); X if displ > maxsize then maxsize := displ; X while lsp3 <> nil do X begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2; X lsp3^.size := displ; X lsp3 := lsp4 X end; X if sy = rparent then X begin insymbol; X if not (sy in fsys + [semicolon]) then X begin error(6); skip(fsys + [semicolon]) end X end X else error(4); X end; X test := sy <> semicolon; X if not test then X begin displ := minsize; X insymbol X end X until test; X displ := maxsize; X lsp^.fstvar := lsp1; X end X else frecvar := nil X end (*fieldlist*) ; X X begin (*typ*) X if not (sy in typebegsys) then X begin error(10); skip(fsys + typebegsys) end; X if sy in typebegsys then X begin X if sy in simptypebegsys then simpletype(fsys,fsp,fsize) X else X (*^*) if sy = arrow then X begin new(lsp,pointer); fsp := lsp; X with lsp^ do X begin eltype := nil; size := ptrsize; form:=pointer end; X insymbol; X if sy = ident then X begin prterr := false; (*no error if search not successful*) X searchid([types],lcp); prterr := true; X if lcp = nil then (*forward referenced type id*) X begin new(lcp,types); X with lcp^ do X begin name := id; idtype := lsp; X next := fwptr; klass := types X end; X fwptr := lcp X end X else X begin X if lcp^.idtype <> nil then X if lcp^.idtype^.form = files then error(108) X else lsp^.eltype := lcp^.idtype X end; X insymbol; X end X else error(2); X end X else X begin X if sy = packedsy then X begin insymbol; X if not (sy in typedels) then X begin X error(10); skip(fsys + typedels) X end X end; X (*array*) if sy = arraysy then X begin insymbol; X if sy = lbrack then insymbol else error(11); X lsp1 := nil; X repeat new(lsp,arrays); X with lsp^ do X begin aeltype := lsp1; inxtype := nil; form:=arrays end; X lsp1 := lsp; X simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize); X lsp1^.size := lsize; X if lsp2 <> nil then X if lsp2^.form <= subrange then X begin X if lsp2 = realptr then X begin error(109); lsp2 := nil end X else X if lsp2 = intptr then X begin error(149); lsp2 := nil end; X lsp^.inxtype := lsp2 X end X else begin error(113); lsp2 := nil end; X test := sy <> comma; X if not test then insymbol X until test; X if sy = rbrack then insymbol else error(12); X if sy = ofsy then insymbol else error(8); X typ(fsys,lsp,lsize); X repeat X with lsp1^ do X begin lsp2 := aeltype; aeltype := lsp; X if inxtype <> nil then X begin getbounds(inxtype,lmin,lmax); X align(lsp,lsize); X lsize := lsize*(lmax - lmin + 1); X size := lsize X end X end; X lsp := lsp1; lsp1 := lsp2 X until lsp1 = nil X end X else X (*record*) if sy = recordsy then X begin insymbol; X oldtop := top; X if top < displimit then X begin top := top + 1; X with display[top] do X begin fname := nil; X flabel := nil; X occur := rec X end X end X else error(250); X displ := 0; X fieldlist(fsys-[semicolon]+[endsy],lsp1); X new(lsp,records); X with lsp^ do X begin fstfld := display[top].fname; X recvar := lsp1; size := displ; form := records X end; X top := oldtop; X if sy = endsy then insymbol else error(13) X end X else X (*set*) if sy = setsy then X begin insymbol; X if sy = ofsy then insymbol else error(8); X simpletype(fsys,lsp1,lsize); X if lsp1 <> nil then X if lsp1^.form > subrange then X begin error(115); lsp1 := nil end X else X if lsp1 = realptr then X begin error(114); lsp1 := nil end X else if lsp1 = intptr then X begin error(169); lsp1 := nil end X else X begin getbounds(lsp1,lmin,lmax); X if (lmin < setlow) or (lmax > sethigh) X then error(169); X end; X new(lsp,power); X with lsp^ do X begin elset:=lsp1; size:=setsize; form:=power end; X end X else X (*file*) if sy = filesy then X begin insymbol; X error(399); skip(fsys); lsp := nil X end; X fsp := lsp X end; X if not (sy in fsys) then X begin error(6); skip(fsys) end X end X else fsp := nil; X if fsp = nil then fsize := 1 else fsize := fsp^.size X end (*typ*) ; X X procedure labeldeclaration; X var llp: lbp; redef: boolean; lbname: integer; X begin X repeat X if sy = intconst then X with display[top] do X begin llp := flabel; redef := false; X while (llp <> nil) and not redef do X if llp^.labval <> val.ival then X llp := llp^.nextlab X else begin redef := true; error(166) end; X if not redef then X begin new(llp); X with llp^ do X begin labval := val.ival; genlabel(lbname); X defined := false; nextlab := flabel; labname := lbname X end; X flabel := llp X end; X insymbol X end X else error(15); X if not ( sy in fsys + [comma, semicolon] ) then X begin error(6); skip(fsys+[comma,semicolon]) end; X test := sy <> comma; X if not test then insymbol X until test; X if sy = semicolon then insymbol else error(14) X end (* labeldeclaration *) ; X X procedure constdeclaration; X var lcp: ctp; lsp: stp; lvalu: valu; X begin X if sy <> ident then X begin error(2); skip(fsys + [ident]) end; X while sy = ident do X begin new(lcp,konst); X with lcp^ do X begin name := id; idtype := nil; next := nil; klass:=konst end; X insymbol; X if (sy = relop) and (op = eqop) then insymbol else error(16); X constant(fsys + [semicolon],lsp,lvalu); X enterid(lcp); X lcp^.idtype := lsp; lcp^.values := lvalu; X if sy = semicolon then X begin insymbol; X if not (sy in fsys + [ident]) then X begin error(6); skip(fsys + [ident]) end X end X else error(14) X end X end (*constdeclaration*) ; X X procedure typedeclaration; X var lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange; X begin X if sy <> ident then X begin error(2); skip(fsys + [ident]) end; X while sy = ident do X begin new(lcp,types); X with lcp^ do X begin name := id; idtype := nil; klass := types end; X insymbol; X if (sy = relop) and (op = eqop) then insymbol else error(16); X typ(fsys + [semicolon],lsp,lsize); X enterid(lcp); X lcp^.idtype := lsp; X (*has any forward reference been satisfied:*) X lcp1 := fwptr; X while lcp1 <> nil do X begin X if lcp1^.name = lcp^.name then X begin lcp1^.idtype^.eltype := lcp^.idtype; X if lcp1 <> fwptr then X lcp2^.next := lcp1^.next X else fwptr := lcp1^.next; X end X else lcp2 := lcp1; X lcp1 := lcp1^.next X end; X if sy = semicolon then X begin insymbol; X if not (sy in fsys + [ident]) then X begin error(6); skip(fsys + [ident]) end X end X else error(14) X end; X if fwptr <> nil then X begin error(117); writeln(output); X repeat writeln(output,' type-id ',fwptr^.name); X fwptr := fwptr^.next X until fwptr = nil; X if not eol then write(output,' ': chcnt+16) X end X end (*typedeclaration*) ; X X procedure vardeclaration; X var lcp,nxt: ctp; lsp: stp; lsize: addrrange; X begin nxt := nil; X repeat X repeat X if sy = ident then X begin new(lcp,vars); X with lcp^ do X begin name := id; next := nxt; klass := vars; X idtype := nil; vkind := actual; vlev := level X end; X enterid(lcp); X nxt := lcp; X insymbol; X end X else error(2); X if not (sy in fsys + [comma,colon] + typedels) then X begin error(6); skip(fsys+[comma,colon,semicolon]+typedels) end; X test := sy <> comma; X if not test then insymbol X until test; X if sy = colon then insymbol else error(5); X typ(fsys + [semicolon] + typedels,lsp,lsize); X while nxt <> nil do X with nxt^ do X begin align(lsp,lc); X idtype := lsp; vaddr := lc; X lc := lc + lsize; nxt := next X end; X if sy = semicolon then X begin insymbol; X if not (sy in fsys + [ident]) then X begin error(6); skip(fsys + [ident]) end X end X else error(14) X until (sy <> ident) and not (sy in typedels); X if fwptr <> nil then X begin error(117); writeln(output); X repeat writeln(output,' type-id ',fwptr^.name); X fwptr := fwptr^.next X until fwptr = nil; X if not eol then write(output,' ': chcnt+16) X end X end (*vardeclaration*) ; X X procedure procdeclaration(fsy: symbol); X var oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp; X forw: boolean; oldtop: disprange; X llc,lcm: addrrange; lbname: integer; markp: marktype; X X procedure parameterlist(fsy: setofsys; var fpar: ctp); X var lcp,lcp1,lcp2,lcp3: ctp; lsp: stp; lkind: idkind; X llc,lsize: addrrange; count: integer; X begin lcp1 := nil; X if not (sy in fsy + [lparent]) then X begin error(7); skip(fsys + fsy + [lparent]) end; X if sy = lparent then X begin if forw then error(119); X insymbol; X if not (sy in [ident,varsy,procsy,funcsy]) then X begin error(7); skip(fsys + [ident,rparent]) end; X while sy in [ident,varsy,procsy,funcsy] do X begin X if sy = procsy then X begin error(399); X repeat insymbol; X if sy = ident then X begin new(lcp,proc,declared,formal); X with lcp^ do X begin name := id; idtype := nil; next := lcp1; X pflev := level (*beware of parameter procedures*); X klass:=proc;pfdeckind:=declared;pfkind:=formal X end; X enterid(lcp); X lcp1 := lcp; X align(parmptr,lc); X (*lc := lc + some size *) X insymbol X end X else error(2); X if not (sy in fsys + [comma,semicolon,rparent]) then X begin error(7);skip(fsys+[comma,semicolon,rparent])end X until sy <> comma X end X else X begin X if sy = funcsy then X begin error(399); lcp2 := nil; X repeat insymbol; X if sy = ident then X begin new(lcp,func,declared,formal); X with lcp^ do X begin name := id; idtype := nil; next := lcp2; X pflev := level (*beware param funcs*); X klass:=func;pfdeckind:=declared; X pfkind:=formal X end; X enterid(lcp); X lcp2 := lcp; X align(parmptr,lc); X (*lc := lc + some size*) X insymbol; X end; X if not (sy in [comma,colon] + fsys) then X begin error(7);skip(fsys+[comma,semicolon,rparent]) SHAR_EOF true || echo 'restore of pcom.p failed' fi echo 'End of part 1' echo 'File pcom.p is continued in part 2' echo 2 > _shar_seq_.tmp exit 0 exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.